home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Disc to the Future 2
/
Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin
/
UNIX
/
PASCAL
/
PTOC
/
PTC.PAT
< prev
next >
Wrap
Text File
|
1992-11-23
|
33KB
|
1,317 lines
*** ptc.p Fri Nov 13 18:45:21 1987
--- nptc.p Fri Nov 13 18:44:29 1987
***************
*** 42,48 ****
(** The code generated by the translator assumes that there is a **)
(** C-implementation with at least a reasonable <stdio> library **)
(** since all input/output is implemented in terms of C functions **)
! (** like fprintf(), getc(), fopen(), rewind() etc. **)
(** If the source-program uses Pascal functions like sin(), sqrt() **)
(** etc, there must also exist such functions in the C-library. **)
(** **)
--- 42,48 ----
(** The code generated by the translator assumes that there is a **)
(** C-implementation with at least a reasonable <stdio> library **)
(** since all input/output is implemented in terms of C functions **)
! (** like fprintf(), getc(), fopen(), fseek() etc. **)
(** If the source-program uses Pascal functions like sin(), sqrt() **)
(** etc, there must also exist such functions in the C-library. **)
(** **)
***************
*** 53,59 ****
label 9999; (* end of program *)
! const version = '@(#)ptc.p 1.5 Date 87/05/01';
keytablen = 38; (* nr of keywords *)
keywordlen = 10; (* length of a keyword *)
--- 53,59 ----
label 9999; (* end of program *)
! const version = '@(#)ptc.p 2.6 Date 87/09/12';
keytablen = 38; (* nr of keywords *)
keywordlen = 10; (* length of a keyword *)
***************
*** 67,75 ****
setbits = 15; (* CPU *)
(* a Pascal file is implemented as a struct which (among other *)
! (* things) contain a flag-field, currently 3 bits are used *)
filebits = 'unsigned short'; (* flags for files *)
! filefill = 12; (* 16 less used 3 bits *)
maxsetrange = 15; (* nr of words in a set *)
scalbase = 0; (* ordinal value of first scalar member *)
--- 67,75 ----
setbits = 15; (* CPU *)
(* a Pascal file is implemented as a struct which (among other *)
! (* things) contain a flag-field, currently 4 bits are used *)
filebits = 'unsigned short'; (* flags for files *)
! filefill = 12; (* 16 less used 4 bits *)
maxsetrange = 15; (* nr of words in a set *)
scalbase = 0; (* ordinal value of first scalar member *)
***************
*** 106,111 ****
--- 106,112 ----
temporary files for reset/rewrite, the last character is supplied
by the reset/rewrite routine *)
tmpfilename = '"/tmp/ptc%d%c", getpid(), '; (* OS *)
+ maxfilename = 'MAXFILENAME';
(* some frequently used characters *)
space = ' ';
***************
*** 146,151 ****
--- 147,154 ----
voidtyp = 'void'; (* for procedures *)
voidcast = '(void)';
+ align = true; (* align literal params *)
+
intlen = 10; (* length of written integer *)
fixlen = 20; (* length of written real *)
***************
*** 239,244 ****
--- 242,264 ----
sinteger: (vint : integer);
sreal: (vflt : strindx);
sstring: (vstr : strindx);
+
+ sand, sarray, sbegin, scase,
+ sconst, sdiv, sdo, sdownto,
+ selse, send, sextern, sfile,
+ sfor, sforward, sfunc, sgoto,
+ sif, sinn, slabel, smod,
+ snil, snot, sof, sor,
+ sother, spacked, sproc, spgm,
+ srecord, srepeat, sset, sthen,
+ sto, stype, suntil, svar,
+ swhile, swith, seof,
+ splus, sminus, smul, squot,
+ sarrow, slpar, srpar, slbrack,
+ srbrack, seq, sne, slt,
+ sle, sgt, sge, scomma,
+ scolon, ssemic, sassign, sdotdot,
+ sdot: ()
end;
(* enumeration of symnode variants *)
***************
*** 648,653 ****
--- 668,674 ----
cstdout, cstderr, cstrncmp, cstrncpy,
cstruct, cstatic, cswitch, ctypedef,
cundef, cungetc, cunion, cunlink,
+ cfseek, cgetchar, cputchar,
cunsigned, cwrite
);
***************
*** 661,667 ****
enew, esetbase, esetsize, eoverflow,
etree, etag, euprconf, easgnconf,
ecmpconf, econfconf, evrntfile, evarfile,
! emanymachs, ebadmach
);
machdefstr = packed array [ 1 .. machdeflen ] of char;
--- 682,688 ----
enew, esetbase, esetsize, eoverflow,
etree, etag, euprconf, easgnconf,
ecmpconf, econfconf, evrntfile, evarfile,
! emanymachs, ebadmach, eprconf
);
machdefstr = packed array [ 1 .. machdeflen ] of char;
***************
*** 683,688 ****
--- 704,711 ----
useins,
usescpy,
usecomp, (* source program uses string-compare *)
+ usealig, (* source program uses aligned params *)
+ usesal,
usefopn, (* source program uses reset/rewrite *)
usescan,
usegetl,
***************
*** 738,745 ****
varno : integer; (* counter for unique id's *)
! hexdig : packed array [ 0 .. 15 ] of char;
(* Prtmsg produces an error message. It asssumes that procedure *)
(* "message" (predefined) will "writeln" to user tty. OS *)
procedure prtmsg(m : errors);
--- 761,771 ----
varno : integer; (* counter for unique id's *)
! pushchr : char; (* pushback for lexical scanner *)
! pushed : boolean;
+ hexdig : array [ 0 .. 15 ] of char;
+
(* Prtmsg produces an error message. It asssumes that procedure *)
(* "message" (predefined) will "writeln" to user tty. OS *)
procedure prtmsg(m : errors);
***************
*** 814,819 ****
--- 840,847 ----
message(restr, 'Too many machine integer types');
ebadmach:
message(inter, 'Bad name for machine integer type');
+ eprconf:
+ message(restr, 'Cannot write conformant arrays');
end;(* case *)
if lastline <> 0 then
begin
***************
*** 1219,1225 ****
var c : char;
begin
! if eof then
c := chr(null)
else begin
colno := colno + 1;
--- 1247,1258 ----
var c : char;
begin
! if pushed then
! begin
! c := pushchr;
! pushed := false
! end
! else if eof then
c := chr(null)
else begin
colno := colno + 1;
***************
*** 1235,1241 ****
else
write(c);
if c = tab1 then
! colno := ((colno div tabwidth) + 1) * tabwidth
end;
if lastchr > 0 then
begin
--- 1268,1275 ----
else
write(c);
if c = tab1 then
! colno := (((colno - 1) div tabwidth) + 1) *
! tabwidth
end;
if lastchr > 0 then
begin
***************
*** 1249,1255 ****
function peekchar : char;
begin
! if eof then
peekchar := chr(null)
else
peekchar := input^
--- 1283,1291 ----
function peekchar : char;
begin
! if pushed then
! peekchar := pushchr
! else if eof then
peekchar := chr(null)
else
peekchar := input^
***************
*** 1458,1466 ****
end;
st := sinteger;
vint := n;
if realok then
begin
- (* accept real numbers *)
if peekchar = '.' then
begin
(* this is a real number *)
--- 1494,1508 ----
end;
st := sinteger;
vint := n;
+ if realok and (peekchar = '.') then
+ begin
+ c := nextchar;
+ realok := numchar(peekchar);
+ pushchr := c;
+ pushed := true
+ end;
if realok then
begin
if peekchar = '.' then
begin
(* this is a real number *)
***************
*** 1579,1585 ****
quote:
begin
(* assume the symbol is a literal string *)
! wl := 0;
ready := false;
repeat
if eoln then
--- 1621,1627 ----
quote:
begin
(* assume the symbol is a literal string *)
! wl := 1;
ready := false;
repeat
if eoln then
***************
*** 1602,1608 ****
end;
if not ready then
begin
! wl := wl + 1;
if wl >= maxtoknlen then
begin
lasttok[lastchr] :=
--- 1644,1650 ----
end;
if not ready then
begin
! wb[wl] := c;
if wl >= maxtoknlen then
begin
lasttok[lastchr] :=
***************
*** 1609,1618 ****
chr(null);
error(elongstring)
end;
! wb[wl] := c
end
until ready;
! if wl = 1 then
begin
(* only 1 character => not a string *)
st := schar;
--- 1651,1660 ----
chr(null);
error(elongstring)
end;
! wl := wl + 1;
end
until ready;
! if wl = 2 then
begin
(* only 1 character => not a string *)
st := schar;
***************
*** 1620,1631 ****
end
else begin
(* > 1 character => its a string *)
- wl := wl + 1;
- if wl >= maxtoknlen then
- begin
- lasttok[lastchr] := chr(null);
- error(elongstring)
- end;
wb[wl] := chr(null);
st := sstring;
vstr := savestr(wb)
--- 1662,1667 ----
***************
*** 2645,2650 ****
--- 2681,2687 ----
sproc, sfunc, sbegin]);
pbody(tp);
checksymbol([sdot]);
+ nextsymbol([seof]);
tp^.tscope := currscope;
leavescope;
pprogram := tp
***************
*** 2662,2668 ****
tp^.tsubid := nil;
tp^.tsubpar := nil;
pbody(tp);
! checksymbol([ssemic]);
tp^.tscope := currscope;
leavescope;
pmodule := tp
--- 2699,2707 ----
tp^.tsubid := nil;
tp^.tsubpar := nil;
pbody(tp);
! checksymbol([ssemic, seof]);
! if currsym.st = ssemic then
! nextsymbol([seof]);
tp^.tscope := currscope;
leavescope;
pmodule := tp
***************
*** 2799,2805 ****
enterscope(dp);
dp := currscope
end;
! nextsymbol([sid, scase] + [cs]);
tq := nil;
while currsym.st = sid do
begin
--- 2838,2844 ----
enterscope(dp);
dp := currscope
end;
! nextsymbol([sid, scase, cs]);
tq := nil;
while currsym.st = sid do
begin
***************
*** 2820,2826 ****
tq^.tbind := ptypedef;
enterscope(dp);
if currsym.st = ssemic then
! nextsymbol([sid, scase] + [cs])
end;
if currsym.st = scase then
begin
--- 2859,2865 ----
tq^.tbind := ptypedef;
enterscope(dp);
if currsym.st = ssemic then
! nextsymbol([sid, scase, cs])
end;
if currsym.st = scase then
begin
***************
*** 2852,2858 ****
tv := nil;
repeat
nextsymbol([sid, sinteger, schar, splus,
! sminus] + [cs]);
if currsym.st = cs then
goto 999;
if tv = nil then
--- 2891,2897 ----
tv := nil;
repeat
nextsymbol([sid, sinteger, schar, splus,
! sminus, cs]);
if currsym.st = cs then
goto 999;
if tv = nil then
***************
*** 3650,3655 ****
--- 3689,3696 ----
tq^.tnext := mknode(nchoise);
tq := tq^.tnext
end;
+ tq^.tchocon := nil;
+ tq^.tchostmt := nil;
tv := nil;
repeat
nextsymbol([sid, sinteger, schar,
***************
*** 3845,3852 ****
if currsym.st = spgm then
top := pprogram
else
! top := pmodule;
! nextsymbol([seof]);
end; (* parse *)
(* Compute value for a node (which must be some kind of constant). *)
--- 3886,3892 ----
if currsym.st = spgm then
top := pprogram
else
! top := pmodule
end; (* parse *)
(* Compute value for a node (which must be some kind of constant). *)
***************
*** 4317,4328 ****
move := true;
sp := ip^.tsym;
if sp^.lid^.inref > 1 then
- begin
sp^.lid :=
! mkrename( 'M', sp^.lid);
! sp^.lid^.inref :=
! sp^.lid^.inref - 1
! end;
ip := nil
end
else
--- 4357,4364 ----
move := true;
sp := ip^.tsym;
if sp^.lid^.inref > 1 then
sp^.lid :=
! mkrename('M', sp^.lid);
ip := nil
end
else
***************
*** 4619,4624 ****
--- 4655,4662 ----
(* mark those used in nested subroutines *)
global(tp^.tsubsub, tp, false);
+ global(tp^.tsubvar, tp, false);
+ global(tp^.tsubtype, tp, false);
(* move out variables used in inner scope *)
movevars(tp, tp^.tsubpar);
***************
*** 4887,4896 ****
a unique name *)
sp := tp^.tsubid^.tsym;
if sp^.lid^.inref > 1 then
! begin
! sp^.lid := mkrename('P', sp^.lid);
! sp^.lid^.inref := sp^.lid^.inref - 1
! end
end;
tp := tp^.tnext
end
--- 4925,4931 ----
a unique name *)
sp := tp^.tsubid^.tsym;
if sp^.lid^.inref > 1 then
! sp^.lid := mkrename('P', sp^.lid)
end;
tp := tp^.tnext
end
***************
*** 5131,5136 ****
--- 5166,5172 ----
const include = '# include ';
define = '# define ';
+ undef = '# undef ';
ifdef = '# ifdef ';
ifndef = '# ifndef ';
elsif = '# else';
***************
*** 5145,5152 ****
var conflag,
setused,
dropset,
- donearr : boolean;
doarrow,
indnt : integer;
procedure increment;
--- 5181,5188 ----
var conflag,
setused,
dropset,
doarrow,
+ donearr : boolean;
indnt : integer;
procedure increment;
***************
*** 5203,5216 ****
(* Emit code to select a record member. *)
procedure eselect(tp : treeptr);
begin
! doarrow := doarrow + 1;
eexpr(tp);
- doarrow := doarrow - 1;
if donearr then
donearr := false
else
! write('.')
end;
(* Emit code for call to a predefined function/procedure. *)
--- 5239,5255 ----
(* Emit code to select a record member. *)
procedure eselect(tp : treeptr);
+ var da : boolean;
+
begin
! da := doarrow;
! doarrow := true;
eexpr(tp);
if donearr then
donearr := false
else
! write('.');
! doarrow := da
end;
(* Emit code for call to a predefined function/procedure. *)
***************
*** 5435,5441 ****
else
write('*.*');
write('s')
! end
end (* case *)
end; (* eformat *)
--- 5474,5482 ----
else
write('*.*');
write('s')
! end;
! 'v':
! fatal(eprconf)
end (* case *)
end; (* eformat *)
***************
*** 5572,5578 ****
write(', ');
eexpr(tq)
end
! end
end (* case *)
end; (* ewrite *)
--- 5613,5621 ----
write(', ');
eexpr(tq)
end
! end;
! 'v':
! fatal(eprconf)
end (* case *)
end; (* ewrite *)
***************
*** 6212,6218 ****
write(', ');
tq := tp^.taparm^.tnext;
if tq = nil then
! write('NULL')
else begin
tq := typeof(tq);
if tq = typnods[tchar] then
--- 6255,6261 ----
write(', ');
tq := tp^.taparm^.tnext;
if tq = nil then
! write('NULL, 0')
else begin
tq := typeof(tq);
if tq = typnods[tchar] then
***************
*** 6221,6234 ****
ch := chr(cvalof(tp^.taparm^.tnext));
if (ch = bslash) or (ch = cite) then
write(bslash);
! write(ch, cite)
end
else if tq = typnods[tstring] then
! eexpr(tp^.taparm^.tnext)
! else if tq^.tt in [narray, nconfarr] then
begin
eexpr(tp^.taparm^.tnext);
! write('.A')
end
else
fatal(etree)
--- 6264,6282 ----
ch := chr(cvalof(tp^.taparm^.tnext));
if (ch = bslash) or (ch = cite) then
write(bslash);
! write(ch, cite, ', -1')
end
else if tq = typnods[tstring] then
! begin
! eexpr(tp^.taparm^.tnext);
! write(', -1')
! end
! else if tq^.tt = narray then
begin
eexpr(tp^.taparm^.tnext);
! write('.A, sizeof(');
! eexpr(tp^.taparm^.tnext);
! write('.A)')
end
else
fatal(etree)
***************
*** 6487,6507 ****
eexpr(tq);
write(')')
end
else
eexpr(tq);
end
! else if (tx = typnods[tstring]) or
! (tx = typnods[tset]) then
begin
- (* cast literal to proper type *)
write('*((');
etypedef(tf^.tup^.tbind);
write(' *)');
! if tx = typnods[tset] then
begin
! dropset := true;
eexpr(tq);
! dropset := false
end
else
eexpr(tq);
--- 6535,6574 ----
eexpr(tq);
write(')')
end
+ else if tf^.tup^.tt = nvarpar then
+ eaddr(tq)
else
+ eexpr(tq)
+ end
+ else if tx = typnods[tset] then
+ begin
+ write('*((');
+ etypedef(tf^.tup^.tbind);
+ write(' *)');
+ dropset := true;
+ if align then
+ begin
+ usesal := true;
+ write('SETALIGN(');
eexpr(tq);
+ write(')')
+ end
+ else
+ eexpr(tq);
+ dropset := false;
+ write(')')
end
! else if tx = typnods[tstring] then
begin
write('*((');
etypedef(tf^.tup^.tbind);
write(' *)');
! if align then
begin
! usealig := true;
! write('STRALIGN(');
eexpr(tq);
! write(')')
end
else
eexpr(tq);
***************
*** 6521,6528 ****
eexpr(tq);
(* add upper bound of actual value *)
if tq^.tnext = nil then
! write(', ',
! crange(tx^.taindx):1)
end
else begin
if tf^.tup^.tt = nvarpar then
--- 6588,6600 ----
eexpr(tq);
(* add upper bound of actual value *)
if tq^.tnext = nil then
! begin
! write(', (');
! eexpr(tx^.taindx^.thi);
! write(' - ');
! eexpr(tx^.taindx^.tlo);
! write(' + 1)')
! end
end
else begin
if tf^.tup^.tt = nvarpar then
***************
*** 6930,6944 ****
eexpr(tp^.texps);
write('.buf')
end
! else if doarrow = 0 then
begin
! write('*');
! eexpr(tp^.texps)
! end
! else begin
eexpr(tp^.texps);
write('->');
donearr := true
end
end;
nid:
--- 7002,7018 ----
eexpr(tp^.texps);
write('.buf')
end
! else if doarrow then
begin
! doarrow := false;
eexpr(tp^.texps);
write('->');
donearr := true
+ end
+ else begin
+ write('(*');
+ eexpr(tp^.texps);
+ write(')')
end
end;
nid:
***************
*** 6947,6966 ****
var-parameter or as a procedure-parameter *)
tq := idup(tp);
if tq^.tt = nvarpar then
! begin
! if (doarrow = 0) or
! (tq^.tattr = areference) then
begin
! write('(*');
printid(tp^.tsym^.lid);
! write(')')
end
else begin
printid(tp^.tsym^.lid);
! write('->');
! donearr := true
end
- end
else if (tq^.tt = nconst) and conflag then
write(cvalof(tp):1)
else if tq^.tt in [nparproc, nparfunc] then
--- 7021,7038 ----
var-parameter or as a procedure-parameter *)
tq := idup(tp);
if tq^.tt = nvarpar then
! if doarrow then
begin
! doarrow := false;
printid(tp^.tsym^.lid);
! write('->');
! donearr := true
end
else begin
+ write('(*');
printid(tp^.tsym^.lid);
! write(')')
end
else if (tq^.tt = nconst) and conflag then
write(cvalof(tp):1)
else if tq^.tt in [nparproc, nparfunc] then
***************
*** 7107,7112 ****
--- 7179,7206 ----
end
end; (* econst *)
+ (* Undefine constants. *)
+ procedure edconst(tp : treeptr);
+
+ var sp : symptr;
+
+ begin
+ while tp <> nil do
+ begin
+ sp := tp^.tidl^.tsym;
+ if tp^.tbind^.tt <> nstring then
+ begin
+ (* all non-strings are emitted as
+ preprocessor # defines *)
+ write(undef);
+ printid(sp^.lid);
+ writeln
+ end;
+ tp := tp^.tnext
+ end
+ end; (* edconst *)
+
+
(* Emit a typedef. *)
procedure etypedef;
***************
*** 7867,7876 ****
ncase:
begin
indent;
! write('switch (');
increment;
eexpr(tp^.tcasxp);
! writeln(') {');
decrement;
echoise(tp^.tcaslst);
indent;
--- 7961,7970 ----
ncase:
begin
indent;
! write('switch ((int)(');
increment;
eexpr(tp^.tcasxp);
! writeln(')) {');
decrement;
echoise(tp^.tcaslst);
indent;
***************
*** 8052,8058 ****
indent;
writeln(' case 0:');
indent;
! writeln(tab1, 'break');
tq := tp^.tsublab;
while tq <> nil do
begin
--- 8146,8152 ----
indent;
writeln(' case 0:');
indent;
! writeln(tab1, 'break;');
tq := tp^.tsublab;
while tq <> nil do
begin
***************
*** 8071,8077 ****
indent;
writeln(' default:');
indent;
! writeln(tab1, 'Caseerror(Line)');
indent;
writeln('}')
end
--- 8165,8171 ----
indent;
writeln(' default:');
indent;
! writeln(tab1, 'Caseerror(Line);');
indent;
writeln('}')
end
***************
*** 8198,8203 ****
--- 8292,8298 ----
writeln(';');
end;
decrement;
+ edconst(tp^.tsubconst);
writeln('}');
999:
writeln;
***************
*** 8337,8345 ****
writeln(define, 'Putl(f, v) (f).eoln = v')
end;
if use(dreset) or use(drewrite) or use(dclose) then
writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
'(Putchr(', nlchr, ', f), 0) : 0, ',
! 'rewind((f).fp)'); (* LIB *)
if use(dclose) then
begin
writeln(define, 'Close(f) (f).init = ',
--- 8432,8443 ----
writeln(define, 'Putl(f, v) (f).eoln = v')
end;
if use(dreset) or use(drewrite) or use(dclose) then
+ begin
writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
'(Putchr(', nlchr, ', f), 0) : 0, ',
! '!fseek((f).fp, 0L, 0)'); (* LIB *)
! writeln(xtern, 'int', tab1, 'fseek();') (* LIB *)
! end;
if use(dclose) then
begin
writeln(define, 'Close(f) (f).init = ',
***************
*** 8359,8371 ****
writeln(elsif);
writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
writeln(endif);
! writeln(define, 'Reset(f, n) (f).init = ',
! '(f).init ? rewind((f).fp) : ', (* LIB *)
! '(((f).fp = Fopen(n, Rmode)), 1), ',
'(f).eof = (f).out = 0, Get(f)');
! writeln(define, 'Resetx(f, n) (f).init = ',
'(f).init ? (Finish(f)) : ',
! '(((f).fp = Fopen(n, Rmode)), 1), ',
'(f).eof = (f).out = 0, Getx(f)');
usefopn := true
end;
--- 8457,8469 ----
writeln(elsif);
writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
writeln(endif);
! writeln(define, 'Reset(f, n, l) (f).init = ',
! '(f).init ? !fseek((f).fp, 0L, 0) : ', (* LIB *)
! '(((f).fp = Fopen(n, l, Rmode)), 1), ',
'(f).eof = (f).out = 0, Get(f)');
! writeln(define, 'Resetx(f, n, l) (f).init = ',
'(f).init ? (Finish(f)) : ',
! '(((f).fp = Fopen(n, l, Rmode)), 1), ',
'(f).eof = (f).out = 0, Getx(f)');
usefopn := true
end;
***************
*** 8376,8388 ****
writeln(elsif);
writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
writeln(endif);
! writeln(define, 'Rewrite(f, n) (f).init = ',
! '(f).init ? rewind((f).fp) : ', (* LIB *)
! '(((f).fp = Fopen(n, Wmode)), 1), ',
'(f).out = (f).eof = 1');
! writeln(define, 'Rewritex(f, n) (f).init = ',
'(f).init ? (Finish(f)) : ',
! '(((f).fp = Fopen(n, Wmode)), 1), ',
'(f).out = (f).eof = (f).eoln = 1');
usefopn := true
end;
--- 8474,8486 ----
writeln(elsif);
writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
writeln(endif);
! writeln(define, 'Rewrite(f, n, l) (f).init = ',
! '(f).init ? !fseek((f).fp, 0L, 0) : ', (* LIB *)
! '(((f).fp = Fopen(n, l, Wmode)), 1), ',
'(f).out = (f).eof = 1');
! writeln(define, 'Rewritex(f, n, l) (f).init = ',
'(f).init ? (Finish(f)) : ',
! '(((f).fp = Fopen(n, l, Wmode)), 1), ',
'(f).out = (f).eof = (f).eoln = 1');
usefopn := true
end;
***************
*** 8389,8395 ****
if usefopn then
begin
writeln('FILE *Fopen();');
! writeln(define, 'MAXFILENAME 256')
end;
if usecase or usejmps then
begin
--- 8487,8495 ----
if usefopn then
begin
writeln('FILE *Fopen();');
! writeln(ifndef, maxfilename);
! writeln(define, maxfilename, ' ', (maxtoknlen+1):1);
! writeln(endif)
end;
if usecase or usejmps then
begin
***************
*** 8443,8449 ****
write(' (');
printid(defnams[dboolean]^.lid);
writeln(')1');
! writeln(xtern, chartyp, tab1, '*Bools[];')
end;
capital(defnams[dinteger]);
if use(dinteger) then
--- 8543,8549 ----
write(' (');
printid(defnams[dboolean]^.lid);
writeln(')1');
! writeln(chartyp, tab1, '*Bools[];')
end;
capital(defnams[dinteger]);
if use(dinteger) then
***************
*** 8519,8527 ****
writeln(setptyp, tab1, 'Insmem(), Mksubr();');
writeln(setptyp, tab1, 'Currset(), Inter();');
writeln(static, setptyp, tab1, 'Tmpset;');
! writeln(xtern, setptyp, tab1, 'Conset[];');
writeln(voidtyp, tab1, 'Setncpy();')
end;
writeln(xtern, chartyp, ' *strncpy();'); (* LIB *)
if use(dargc) or use(dargv) then
begin
--- 8619,8640 ----
writeln(setptyp, tab1, 'Insmem(), Mksubr();');
writeln(setptyp, tab1, 'Currset(), Inter();');
writeln(static, setptyp, tab1, 'Tmpset;');
! writeln(setptyp, tab1, 'Conset[];');
writeln(voidtyp, tab1, 'Setncpy();')
end;
+ if align then (* CPU *)
+ begin
+ writeln(ifndef, 'SETALIGN');
+ writeln(define, 'SETALIGN(x) Alignset(x)');
+ writeln('struct Set { ', wordtype, tab1, 'S[',
+ maxsetrange:1, '+1]; } *Alignset();');
+ writeln(endif);
+ writeln(ifndef, 'STRALIGN');
+ writeln(define, 'STRALIGN(x) Alignstr(x)');
+ writeln('struct String { char A[',
+ maxtoknlen:1, '+1]; } *Alignstr();');
+ writeln(endif)
+ end;
writeln(xtern, chartyp, ' *strncpy();'); (* LIB *)
if use(dargc) or use(dargv) then
begin
***************
*** 8577,8589 ****
--- 8690,8711 ----
writeln('main()');
writeln('{')
end;
+ if use(dinput) then
+ begin
+ writeln(ifdef, 'STDINIT');
+ writeln(tab1, voidcast, '(Getx(input));');
+ writeln(endif)
+ end;
increment;
elabel(tp);
estmt(tp^.tsubstmt);
indent;
writeln('exit(0);');
+ indent;
+ writeln('/', '* NOTREACHED *', '/');
decrement;
writeln('}');
+ edconst(tp^.tsubconst);
writeln('/', '*');
writeln('** End of program code');
writeln('*', '/')
***************
*** 8716,8725 ****
conflag := false;
setused := false;
dropset := false;
! doarrow := 0;
eprogram(top);
if usebool then
! writeln(chartyp, tab1, '*Bools[] = { "false", "true" };');
if usescan then
begin
writeln;
--- 8838,8848 ----
conflag := false;
setused := false;
dropset := false;
! doarrow := false;
! donearr := false;
eprogram(top);
if usebool then
! writeln(static, chartyp, tab1, '*Bools[] = { "false", "true" };');
if usescan then
begin
writeln;
***************
*** 8749,8770 ****
begin
writeln;
writeln(static, 'FILE *');
! writeln('Fopen(n, m)');
writeln(chartyp, tab1, '*n, *m;');
writeln('{');
writeln(tab1, 'FILE', tab2, '*f;');
writeln(tab1, registr, chartyp, tab1, '*s;');
writeln(tab1, static, chartyp, tab1, 'ch = ',
quote, 'A', quote, ';');
! writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];');
! writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *)
writeln;
writeln(tab1, 'if (n == NULL)');
writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
writeln(tab1, 'else {');
writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
! spchr, ' || *s == ', nulchr, '; )');
writeln(tab3, '*s-- = ', nulchr, ';');
writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
--- 8872,8897 ----
begin
writeln;
writeln(static, 'FILE *');
! writeln('Fopen(n, l, m)');
writeln(chartyp, tab1, '*n, *m;');
+ writeln(inttyp, tab1, 'l;');
writeln('{');
writeln(tab1, 'FILE', tab2, '*f;');
writeln(tab1, registr, chartyp, tab1, '*s;');
writeln(tab1, static, chartyp, tab1, 'ch = ',
quote, 'A', quote, ';');
! writeln(tab1, static, chartyp, tab1, 'tmp[', maxfilename, '];');
! writeln(tab1, xtern , inttyp, tab1, 'unlink(),'); (* OS *)
! writeln(tab3, 'strlen();'); (* OS *)
writeln;
writeln(tab1, 'if (n == NULL)');
writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
writeln(tab1, 'else {');
+ writeln(tab2, 'if (l < 0)');
+ writeln(tab3, 'l = strlen(n);');
writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
! spchr, ' || *s == ', nulchr, ' || s - tmp > l; )');
writeln(tab3, '*s-- = ', nulchr, ';');
writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
***************
*** 8782,8788 ****
writeln(tab2, 'unlink(tmp);'); (* OS *)
writeln(tab1, 'return (f);');
writeln('}');
- writeln(xtern, inttyp, tab1, 'rewind();')
end;
if setcnt > 0 then
econset(setlst, setcnt);
--- 8909,8914 ----
***************
*** 9098,9106 ****
writeln(tab2, '*S1++ = 0;');
writeln('}')
end;
! if usecase then
begin
writeln;
writeln(static, voidtyp);
writeln('Caseerror(n)');
writeln(tab1, inttyp, tab1, 'n;');
--- 9224,9263 ----
writeln(tab2, '*S1++ = 0;');
writeln('}')
end;
! if usesal then
begin
writeln;
+ writeln(static, 'struct Set *');
+ writeln('Alignset(Sp)');
+ writeln(tab1, registr, wordtype, tab1, '*Sp;');
+ writeln('{');
+ writeln(tab1, static, 'struct Set', tab1, 'tmp;');
+ writeln(tab1, registr, wordtype, tab1, '*tp = tmp.S;');
+ writeln(tab1, registr, inttyp, tab2, 'i = *Sp;');
+ writeln;
+ writeln(tab1, 'while (i-- >= 0)');
+ writeln(tab2, '*tp++ = *Sp++;');
+ writeln(tab1, 'return (&tmp);');
+ writeln('}')
+ end;
+ if usealig then
+ begin
+ writeln;
+ writeln(static, 'struct String *');
+ writeln('Alignstr(Cp)');
+ writeln(tab1, registr, chartyp, tab1, '*Cp;');
+ writeln('{');
+ writeln(tab1, static, 'struct String', tab1, 'tmp;');
+ writeln(tab1, registr, chartyp, tab1, '*sp = tmp.A;');
+ writeln;
+ writeln(tab1, 'while (*sp++ = *Cp++)');
+ writeln(tab2, ';');
+ writeln(tab1, 'return (&tmp);');
+ writeln('}')
+ end;
+ if usecase or usejmps then
+ begin
+ writeln;
writeln(static, voidtyp);
writeln('Caseerror(n)');
writeln(tab1, inttyp, tab1, 'n;');
***************
*** 9108,9113 ****
--- 9265,9271 ----
writeln(tab1, voidcast,
'fprintf(stderr, "Missing case limb: line %d\n", n);');
writeln(tab1, 'exit(1);');
+ writeln(tab1, '/', '* NOTREACHED *', '/');
writeln('}')
end;
if usemax then
***************
*** 9153,9158 ****
--- 9311,9318 ----
t : pretyps;
d : predefs;
+ hx : packed array [ 1 .. 16 ] of char;
+
(* Define names in ctable. *)
procedure defname(cn : cnames; str : keyword);
***************
*** 9328,9339 ****
begin (* initialize *)
lineno := 1;
colno := 0;
initstrstore;
setlst := nil;
setcnt := 0;
! hexdig := '0123456789ABCDEF';
symtab := nil;
statlvl := 0;
--- 9488,9501 ----
begin (* initialize *)
lineno := 1;
colno := 0;
+ pushed := false;
initstrstore;
setlst := nil;
setcnt := 0;
! hx := '0123456789ABCDEF';
! unpack(hx, hexdig, 0);
symtab := nil;
statlvl := 0;
***************
*** 9366,9371 ****
--- 9528,9535 ----
usecomp := false;
usemax := false;
+ usealig := false;
+ usesal := false;
for s := 0 to hashmax do
idtab[s] := nil;
***************
*** 9541,9546 ****
--- 9705,9713 ----
defname(cungetc, 'ungetc '); (* LIB *)
defname(cunion, 'union ');
defname(cunlink, 'unlink '); (* OS *)
+ defname(cfseek, 'fseek '); (* LIB *)
+ defname(cgetchar, 'getchar '); (* LIB *)
+ defname(cputchar, 'putchar '); (* LIB *)
defname(cunsigned, 'unsigned ');
defname(cwrite, 'write '); (* OS *)
***************
*** 9613,9619 ****
describing type, fill in constant identifying type *)
case t of
tboolean:
! typnods[t] := deftab[dboolean]; (* scalar type *)
tchar:
typnods[t] := deftab[dchar]^.tbind;
tinteger:
--- 9780,9786 ----
describing type, fill in constant identifying type *)
case t of
tboolean:
! typnods[t] := deftab[dboolean]^.tbind;
tchar:
typnods[t] := deftab[dchar]^.tbind;
tinteger:
